home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / debug / sortedset.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  6.1 KB  |  225 lines
  1. signature SORTED_SET_ITEM =
  2. sig
  3.   type t
  4.   type k
  5.   val key: t -> k
  6.   val lt : k * k -> bool
  7. end
  8.  
  9. signature SORTED_SET =
  10. sig
  11.   type s
  12.   type t
  13.   type k
  14.   exception NotFound
  15.   exception DuplicateKey
  16.   val new: unit -> s
  17.   val insert: s * t -> s
  18.   val delete: s * k -> s
  19.   val find: s * k -> t (* exact match *)
  20.   val findp: s * k -> t (* pred match *)
  21.   val finds: s * k -> t (* succ match *)
  22.   val findc: s * (t->bool) -> t (* first to match monotonic condition *)
  23.   val update: s * t -> s (* must already exist *)
  24.   val iterate: s * (t->'a) -> unit (* lowest to highest *)
  25.   val iteratefrom : s * k * (t->'a) -> unit (* lowest to highest from start *)
  26.   val fold: s * ((t * 'a) -> 'a) * 'a -> 'a    (* highest first order *)
  27.   val revfold: s * ((t * 'a) -> 'a) * 'a -> 'a (* lowest first order *)
  28.   val size: s -> int
  29. end
  30.  
  31. functor SortedSet (I:SORTED_SET_ITEM) : SORTED_SET =
  32. (* RB-tree insertion implementation courtesy A. Appel *)
  33. struct
  34.  open I
  35.  val op< = lt
  36.  datatype color = RED | BLACK
  37.  datatype tree = empty | tree of (t * bool) * color * tree * tree
  38.  type s = tree * int (* valid count *) * int (* invalid count *)
  39.  exception NotFound
  40.  exception DuplicateKey
  41.  
  42.  fun key' (n,v) = key n
  43.  
  44.  fun new () = (empty,0,0)
  45.  
  46.  fun insert ((s,vc,ivc),n) =
  47.   let val reused = ref false
  48.       fun f empty = tree((n,true),RED,empty,empty)
  49.         | f (s as tree(t as (_,v),BLACK,l,r)) =
  50.         if key' t < key n
  51.         then case f r
  52.          of r as tree(rt,RED, rl as tree(rlt,RED,rll,rlr),rr) =>
  53.             (case l
  54.              of tree(lt,RED,ll,lr) =>
  55.                 tree(t,RED,tree(lt,BLACK,ll,lr),
  56.                        tree(rt,BLACK,rl,rr))
  57.               | _ => tree(rlt,BLACK,tree(t,RED,l,rll),
  58.                         tree(rt,RED,rlr,rr)))
  59.           | r as tree(rt,RED,rl, rr as tree(rrt,RED,rrl,rrr)) =>
  60.             (case l
  61.              of tree(lt,RED,ll,lr) =>
  62.                 tree(t,RED,tree(lt,BLACK,ll,lr),
  63.                        tree(rt,BLACK,rl,rr))
  64.               | _ => tree(rt,BLACK,tree(t,RED,l,rl),rr))
  65.               | r => tree(t,BLACK,l,r)
  66.         else if key n < key' t
  67.         then case f l
  68.              of l as tree(lt,RED,ll, lr as tree(lrt,RED,lrl,lrr)) =>
  69.             (case r
  70.              of tree(rt,RED,rl,rr) =>
  71.                 tree(t,RED,tree(lt,BLACK,ll,lr),
  72.                        tree(rt,BLACK,rl,rr))
  73.               | _ => tree(lrt,BLACK,tree(lt,RED,ll,lrl),
  74.                         tree(t,RED,lrr,r)))
  75.           | l as tree(lt,RED, ll as tree(llt,RED,lll,llr), lr) =>
  76.             (case r
  77.              of tree(rt,RED,rl,rr) =>
  78.                 tree(t,RED,tree(lt,BLACK,ll,lr),
  79.                        tree(rt,BLACK,rl,rr))
  80.               | _ => tree(lt,BLACK,ll,tree(t,RED,lr,r)))
  81.               | l => tree(t,BLACK,l,r)
  82.         else if v then
  83.            raise DuplicateKey
  84.          else (reused := true; tree((n,true),BLACK,l,r))
  85.         | f (s as tree(t as (_,v),RED,l,r)) =
  86.         if key' t < key n then tree(t,RED,l, f r)
  87.         else if key n < key' t then tree(t,RED, f l, r)
  88.         else if v then
  89.            raise DuplicateKey
  90.          else (reused := true; tree((n,true),RED,l,r))
  91.       val s' =
  92.         case f s of
  93.       tree(t,RED, l as tree(_,RED,_,_), r) => tree(t,BLACK,l,r)
  94.     | tree(t,RED, l, r as tree(_,RED,_,_)) => tree(t,BLACK,l,r)
  95.     | s => s
  96.   in (s',vc+1,if !reused then ivc - 1 else ivc)
  97.   end
  98.  
  99.  fun find((s,_,_),k) =
  100.   let fun look empty = raise NotFound
  101.     | look (tree(t as (n,v),_,l,r)) =
  102.         if k < key' t then look l
  103.         else if key' t < k then look r
  104.         else if v then n
  105.         else raise NotFound
  106.    in look s
  107.   end
  108.  
  109.  
  110.  fun findp((s,_,_),k) = (* return item or its predecessor *)
  111.   let fun match empty = raise NotFound
  112.         | match (tree(t as(n,v),_,l,r)) =
  113.         if k < key' t then 
  114.           match l
  115.         else if key' t < k then
  116.           (match r) handle NotFound => 
  117.                    if v then 
  118.                  n 
  119.                else lookmax l
  120.         else if v then
  121.           n 
  122.         else lookmax l
  123.       and lookmax empty = raise NotFound
  124.     | lookmax (tree(t as (n,v),_,l,r)) =
  125.         (lookmax r) handle NotFound => 
  126.                     if v then 
  127.                   n 
  128.                 else lookmax l
  129.   in match s
  130.   end        
  131.  
  132.  fun finds((s,_,_),k) = (* return item or its successor *)
  133.   let fun match empty = raise NotFound
  134.         | match (tree(t as (n,v),_,l,r)) =
  135.         if k < key' t then 
  136.           (match l) handle NotFound =>
  137.                    if v then 
  138.                  n
  139.                else lookmin r
  140.         else if key' t < k then
  141.           match r
  142.         else if v then
  143.           n
  144.         else lookmin r
  145.       and lookmin empty = raise NotFound
  146.     | lookmin (tree(t as (n,v),_,l,r)) =
  147.         (lookmin l) handle NotFound => 
  148.                     if v then 
  149.                   n 
  150.                 else lookmin r
  151.   in match s
  152.   end        
  153.  
  154.  
  155.  fun findc((s,_,_),cond) = (* returns first item to match monotonic cond *)
  156.   let fun match empty = raise NotFound
  157.         | match (tree(t as (n,v),_,l,r)) =
  158.         if v then
  159.           if cond n then 
  160.             (match l) handle NotFound => n
  161.           else match r
  162.         else (match l) handle NotFound => match r
  163.   in match s
  164.   end        
  165.  
  166.  fun update((s,vc,ivc),n) =
  167.    let fun look empty = raise NotFound
  168.          | look (tree(t as (_,v),c,l,r)) =
  169.           if key n < key' t then tree(t,c,look l,r)
  170.           else if key' t < key n then tree(t,c,l,look r)
  171.           else if v then tree((n,true),c,l,r)
  172.               else raise NotFound
  173.    in (look s,vc,ivc)
  174.    end 
  175.  
  176.   fun iteratefrom ((s,_,_),k,f) =
  177.     let fun g empty = ()
  178.           | g (tree(t as (n,v),_,l,r)) =
  179.           (if k < key' t then g l else ();
  180.            if not(key' t < k) andalso v then (f n;()) else ();
  181.            g r)
  182.     in g s           
  183.     end        
  184.  
  185.   fun iterate ((s,_,_),f) =
  186.     let fun g empty = ()
  187.           | g (tree(t as (n,v),_,l,r)) = 
  188.              (g l; if v then (f n;()) else (); g r)
  189.     in g s
  190.     end
  191.  
  192.   fun fold ((s,_,_),f,i) =
  193.     let fun g (empty,a) = a 
  194.       | g (tree(t as (n,v),_,l,r),a) = 
  195.              if v then g(l,f(n,g(r,a)))
  196.          else g(l,g(r,a))
  197.     in g (s,i)
  198.     end        
  199.         
  200.   fun revfold((s,_,_),f,i) =
  201.     let fun g (empty,a) = a
  202.           | g (tree(t as (n,v),_,l,r),a) =
  203.              if v then g(r,f(n,g(l,a)))
  204.          else g(r,g(l,a))
  205.     in g (s,i)
  206.     end
  207.  
  208.  fun delete(set as (s,vc,ivc),k) = 
  209.   let fun look empty = raise NotFound
  210.         | look (tree(t as (n,v),c,l,r)) =
  211.          if k < key' t then tree(t,c,look l,r)
  212.          else if key' t < k then tree(t,c,l,look r)
  213.          else if v then tree((n,false),c,l,r)
  214.          else raise NotFound
  215.       val (set' as (s',vc',ivc')) = (look s,vc-1,ivc+1)
  216.   in if vc' > ivc' then 
  217.        set'
  218.      else (* reorganize *)
  219.        (fold(set',fn (n,set'') => insert(set'',n),new()))
  220.   end 
  221.  
  222.   fun size (_,vc,_) = vc
  223.  
  224. end (* functor *)
  225.